home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / puzzle / statepos.cls < prev   
Text File  |  1999-09-07  |  8KB  |  254 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "Stateposition"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  17.  
  18. Dim position(3, 3) As Integer          ' 2-dimensional array that holds current state
  19.  
  20. Dim children() As New Stateposition    ' dynamic array of children
  21.  
  22. Public step As Integer                 ' current depth of evaluation
  23.  
  24. Public closed As Boolean               ' indicates that all children were expanded
  25.  
  26. Public parent As Stateposition         ' pointer to a parent position
  27. Public curvalue As Integer
  28.  
  29. Public xempty As Integer               ' x and y coordinate of an empty
  30. Public yempty As Integer               ' tile in an array
  31.  
  32. Public onpath As Boolean               ' indicator that this state is on solution path
  33.  
  34. Public numberchildren As Integer       ' number of states possibly derived
  35.  
  36. Public last As Integer                 '  indicates the move that brought to
  37.                                        ' this position
  38.                                        
  39. Public nextstate As New Stateposition
  40.  
  41. Private Sub Class_Initialize()
  42.                            ' initially state is not closed and not on solution path
  43.                            ' to be maximum
  44.  closed = False
  45.  numberchildren = 0
  46.  onpath = False
  47. End Sub
  48.  
  49. ' evaluation function. curvalue equals to sum of distances of all displaced tiles and
  50. ' current depth of evaluation (step). Returns true for final solution ,false otherwise
  51.  
  52. Public Function evaluate() As Boolean
  53.  
  54.  Dim i As Integer
  55.  Dim j As Integer
  56.  Dim x As Integer
  57.  Dim temp As Integer
  58.  
  59.  curvalue = step       ' initialize curvalue to step
  60.  
  61.  For i = 0 To 2
  62.    For j = 0 To 2
  63.       temp = 3 * i + j          ' value supposed to be in (i,j) in array
  64.        
  65.       If (temp = position(i, j)) Then          ' Tile is in place
  66.         
  67.       ElseIf (Not position(i, j) = 0) Then     ' evaluating displacement distance
  68.       
  69.         curvalue = curvalue + Math.Abs(position(i, j) \ 3 - i) _
  70.          + Math.Abs((position(i, j) Mod 3) - j)
  71.       End If
  72.    Next
  73.  Next
  74.  If curvalue = step Then                ' means that this state is solution
  75.    Puzzle.finished = True
  76.    Puzzle.setpath Me
  77.    evaluate = True
  78.  Else
  79.    evaluate = False
  80.  End If
  81. End Function
  82.  
  83. ' Sub that copies array of tiles from parent to child
  84.  
  85. Public Sub makearray(temp() As Integer)
  86.   Dim i As Integer
  87.   Dim j As Integer
  88.   
  89.   For i = 0 To 2
  90.    For j = 0 To 2
  91.     position(i, j) = temp(i, j)
  92.     If (temp(i, j) = 0) Then
  93.      xempty = i                   ' Also copy the location of empty tile
  94.      yempty = j
  95.     End If
  96.    Next
  97.   Next
  98.   
  99. End Sub
  100.  
  101.  
  102. ' sub that expands all children of the state (breadth first) except of one that is identical
  103. ' to the states parent (to avoid repetitions).
  104.  
  105. Public Sub expandchildren()
  106.  
  107.    If (xempty > 0 And Not (last = 3)) Then           ' move empty tile up
  108.     numberchildren = 1
  109.     ReDim Preserve children(1)                       ' create child and add it to array
  110.     Set children(0) = New Stateposition
  111.     Set children(0).parent = Me
  112.     children(0).step = Me.step + 1
  113.     children(0).last = 1                             ' last move of the child was up
  114.     children(0).makearray position
  115.     children(0).makemove 1                           ' change state for a child
  116.    End If
  117.     
  118.    If (yempty > 0 And Not (last = 4)) Then           ' the same but go left
  119.     numberchildren = numberchildren + 1
  120.     ReDim Preserve children(numberchildren)
  121.     Set children(numberchildren - 1) = New Stateposition
  122.     Set children(numberchildren - 1).parent = Me
  123.     children(numberchildren - 1).step = Me.step + 1
  124.     children(numberchildren - 1).last = 2
  125.     children(numberchildren - 1).makearray position
  126.     children(numberchildren - 1).makemove 2
  127.    End If
  128.     
  129.    If (xempty < 2 And Not (last = 1)) Then          ' the same but go down
  130.     numberchildren = numberchildren + 1
  131.     ReDim Preserve children(numberchildren)
  132.     Set children(numberchildren - 1) = New Stateposition
  133.     Set children(numberchildren - 1).parent = Me
  134.     children(numberchildren - 1).step = Me.step + 1
  135.     children(numberchildren - 1).last = 3
  136.     children(numberchildren - 1).makearray position
  137.     children(numberchildren - 1).makemove 3
  138.    End If
  139.    
  140.    If (yempty < 2 And Not (last = 2)) Then           ' the same but go right
  141.     numberchildren = numberchildren + 1
  142.     ReDim Preserve children(numberchildren)
  143.     Set children(numberchildren - 1) = New Stateposition
  144.     Set children(numberchildren - 1).parent = Me
  145.     children(numberchildren - 1).step = Me.step + 1
  146.     children(numberchildren - 1).last = 4
  147.     children(numberchildren - 1).makearray position
  148.     children(numberchildren - 1).makemove 4
  149.    End If
  150. End Sub
  151.  
  152. ' sub that changes array of tiles of the current state according to the last move made (since
  153. ' we've copied array from parent we need to do it).
  154.  
  155. Public Sub makemove(flag As Integer)
  156.     
  157.   Select Case flag
  158.   Case 1                         ' moving up
  159.     position(xempty, yempty) = position(xempty - 1, yempty)
  160.     position(xempty - 1, yempty) = 0
  161.     
  162.     xempty = xempty - 1
  163.   Case 2                          ' moving left
  164.     position(xempty, yempty) = position(xempty, yempty - 1)
  165.     position(xempty, yempty - 1) = 0
  166.   
  167.     yempty = yempty - 1
  168.   Case 3                         ' moving down
  169.     position(xempty, yempty) = position(xempty + 1, yempty)
  170.     position(xempty + 1, yempty) = 0
  171.     
  172.     xempty = xempty + 1
  173.   Case 4                         ' moving right
  174.     position(xempty, yempty) = position(xempty, yempty + 1)
  175.     position(xempty, yempty + 1) = 0
  176.   
  177.     yempty = yempty + 1
  178.   End Select
  179.   
  180. End Sub
  181.  
  182.  ' returns a child with correspondent index from array of children
  183.  
  184. Public Function getchild(index As Integer) As Stateposition
  185.  Set getchild = children(index)
  186. End Function
  187.  
  188. ' shows current state and used only for debugging
  189.  
  190. Public Sub show()
  191.  Dim i As Integer
  192.  Dim j As Integer
  193.  Dim temp As String
  194.   For i = 0 To 2
  195.    For j = 0 To 2
  196.     temp = temp & " " & position(i, j)
  197.    Next
  198.    temp = temp & vbCrLf
  199.   Next
  200.   MsgBox temp
  201.   
  202. End Sub
  203.  
  204.  
  205. ' after finding solution path redraws state one by one from initial to the solution
  206.  
  207. Public Sub redrawstate()
  208.  Dim x As Integer
  209.  Dim y As Integer
  210.  Dim index As Integer
  211.  Dim num As Integer
  212.  
  213.  y = Puzzle.translatey(parent.xempty)
  214.  x = Puzzle.translatex(parent.yempty)
  215.  
  216.   Select Case last
  217.    Case 1                                   ' empty was moved up so find button beneath
  218.                                            ' and move it up
  219.     index = Puzzle.findbutton(x, y - 1320)
  220.    Case 2
  221.     index = Puzzle.findbutton(x - 1320, y)
  222.    Case 3
  223.     index = Puzzle.findbutton(x, y + 1320)
  224.    Case 4
  225.     index = Puzzle.findbutton(x + 1320, y)
  226.   End Select
  227.  
  228.   For num = 7 To -1 Step -1
  229.    If (last = 1) Then
  230.     Puzzle.Command1(index).Move x, y - (num + 1) * 165
  231.    ElseIf (last = 2) Then
  232.     Puzzle.Command1(index).Move x - (num + 1) * 165, y
  233.    ElseIf (last = 3) Then
  234.     Puzzle.Command1(index).Move x, y + (num + 1) * 165
  235.    ElseIf (last = 4) Then
  236.     Puzzle.Command1(index).Move x + (num + 1) * 165, y
  237.    End If
  238.    Puzzle.Refresh
  239.    Sleep 200
  240.    DoEvents
  241.   Next
  242. End Sub
  243.  
  244. Public Sub freechild()             ' cleaning memory. sets references to
  245.  Dim i As Integer                  ' all children and parents to nothing
  246.   
  247.   For i = 0 To numberchildren - 1
  248.    Set children(i) = Nothing
  249.   Next
  250.   
  251.   Set parent = Nothing
  252. End Sub
  253.  
  254.